unit CPTokenizer;

interface

uses Contnrs, Classes, SysUtils, CPParserBase, CPToken;

type
  { Stores a list of tokens and provides means to iterate through it }
  TCPTokenList = class(TObjectList)
  private
    FTokenIndex: Integer;
    function GetTokens(Index: Integer): TCPToken;
    procedure SetTokens(Index: Integer; const Value: TCPToken);
    function GetCurrent: TCPToken;
    function GetPrevious: TCPToken;
  public
    { Selects the first token in the list }
    procedure SelectFirst;
    { Sleects the next token in the list }
    function SelectNext: Boolean;
    { Gets or sets a token of this list }
    property Tokens[Index: Integer]: TCPToken read GetTokens write SetTokens;
    default;
    { Gets the token after the token currently selected. If the current token
      is the last token then nil is returned. }
    property Previous: TCPToken read GetPrevious;
    { Gets the token currently selected. }
    property Current: TCPToken read GetCurrent;
  end;

  { Reads in a mathematical expression and generates a token list }
  TCPTokenizer = class
  private
    { Text sequence that is read in by this tokenizer instance }
    FSequence: TCPTextSequence;
    { Current read position of this tokenizer instance }
    FIndex: Integer;
    { Stop index of last token added. If no token was added yet, this
      is the first character of the scanned sequence. }
    FTokenStopIndex: Integer;
    { Contains the last non-whitespace token that was added }
    FLastToken: TCPToken;
    { List with non-whitespace tokens }
    FTokens: TCPTokenList;
    { List with whitespace tokens }
    FWhitespaceTokens: TCPTokenList;
    { Stores token kinds that are accepted as next element }
    FExpected: TCPExpectedTokenKind;
    { Holds the set of the next tokens right after a token has been
      read. }
    FInitialExpected: TCPExpectedTokenKind;
    { Paren level after current token }
    FParenLevel: Integer;
    { Adds the specified token to the token list and sets its sequence from
      the end of the last token to the current read position. If the token
      is white space then it is added to a special token lust for whitespace
      only.
      @param Token Token that is added to the token list
      @return The added token instance }
    function AddToken(Token: TCPToken): TCPToken;
    { Checks if a sequence of digits is found at the current read position.
      @return The position after the last digit, if at least one
      digit is found; otherwise, -1 is returned. }
    function CheckDigits: Integer;
    { Checks if the specified text is found at the current read position.
      @return The current read position, if Text is found; otherwise,
      -1 is returned. }
    function CheckString(const Text: string): Integer;
    { Raises the specified tokenize error exception. Start and Stop mark the
      erroneous character sequence.
      @param TokenizeErrorClass Class type of the exception that is raised
      @param Start Start index of the erroneous character sequence
      @param Stop Stop index of the erroneous character sequence }
    procedure RaiseError(ErrorCode: TCPErrorCode;
      Expected: TCPExpectedTokenKind; Start: Integer; Stop: Integer = -1);
    { Attempts to read in an function argument separator and adds it as token
      @return True, if a argument separator was found; otherwise, false is
      returned. }
    function ScanArgSeparator: Boolean;
    { Attempts to read in an identifier and adds it as token
      @return True, if an identifier was found; otherwise, false is returned. }
    function ScanIdentifier: Boolean;
    { Attempts to read in a number literal and adds it as token
      @return True, if a number was found; otherwise, false is returned. }
    function ScanNumber: Boolean;
    { Attempts to read in an mathematical operator and adds it as token
      @return True, if an operator was found; otherwise, false is returned. }
    function ScanOperator: Boolean;
    { Attempts to read in a parenthesis and adds it as token
      @return True, if parenthesis was found; otherwise, false is returned. }
    function ScanParen: Boolean;
    { Attempts to read in an operand (number, variable or built-in function).
      Optional signs preceding the operand are rea din as well.
      @return True, if parenthesis was found; otherwise, false is returned. }
    function ScanOperand: Boolean;
    { Attempts to read in a positive or negative sign and adds it as token
      @return True, if sign was found; otherwise, false is returned. }
    function ScanSign: Boolean;
    { Attempts to read in a sequence of whitespace characters and adds it as
      token
      @return True, if whitespace was found; otherwise, false is returned. }
    function ScanWhitespace: Boolean;
    { Checks if the specified character can be part of any valid token.
      @return True if the character is part of tokens; if the character is
        not used in any token then false is returned. }
    class function IsTokenCharacter(C: Char): Boolean;
    { Returns the set of expected tokens as a human-readable string }
    class function GetExpectedTokenAsString(Expected: TCPExpectedTokenKind)
      : string;
  public
    { Creates a new tokenizer instance }
    constructor Create;
    destructor Destroy; override;
    { Returns true, if character is a digit (0-9)
      @return True, if character is a digit; otherwise, false is returned. }
    class function IsDigit(C: Char): Boolean;
    { Returns true, if character is a letter
      @return True, if character is a letter; otherwise, false is returned. }
    class function IsLetter(C: Char): Boolean;
    { Returns true, if the specified character is a whitespace character;
      otherwise, false is returned. }
    class function IsWhitespace(C: Char): Boolean;
    { Checks if the specified character is a valid character of an identifier.
      Since special rules apply for the first character of an identifier, the
      parameter FirstCharacter specifies if the specified character is the
      first character of an identifier.
      @param C Character that is to be checked
      @param FirstCharacter Specifies, if the character is the first character
      of the identifier.
      @return True, if the character is a valid character of an identifier;
      otherwise, false is returned. }
    class function IsIdentifier(C: Char; FirstCharacter: Boolean): Boolean;
    { Tokenizes the expression specified by the string sequence }
    procedure Tokenize;
    { Gets or sets the string sequence that will get tokenized }
    property Sequence: TCPTextSequence read FSequence write FSequence;
    { Gets the list with read non-whitesapce tokens }
    property Tokens: TCPTokenList read FTokens;
    { Gets the list with read whitesapce tokens }
    property WhitespaceTOkens: TCPTokenList read FWhitespaceTokens;
  end;

implementation

{ TCPTokenizer }

uses {$IFDEF UNICODE} Character, {$ENDIF} StrUtils, gnugettext;

function TCPTokenizer.AddToken(Token: TCPToken): TCPToken;
begin
  // Create token after last token to the current position:
  Result := Token;
  Result.Sequence := TCPTextSequence.Create(FSequence.Text, FTokenStopIndex,
    FIndex);

  // Add token to token list:
  if (Result.Kind = tkWhitespace) then
    FWhitespaceTokens.Add(Result)
  else
  begin
    FTokens.Add(Result);
    FLastToken := Result;
  end;
  FTokenStopIndex := FIndex;
{$IFDEF DEBUGPARSER} Writeln(Token.ToString); {$ENDIF}
end;

constructor TCPTokenizer.Create;
begin
  FTokens := TCPTokenList.Create;
  FWhitespaceTokens := TCPTokenList.Create;
end;

destructor TCPTokenizer.Destroy;
begin
  FTokens.Free;
  FWhitespaceTokens.Free;
  inherited;
end;

class function TCPTokenizer.IsLetter(C: Char): Boolean;
begin
{$IFDEF UNICODE}
  Result := TCharacter.IsLetter(C);
{$ELSE}
  Result := C in ['A' .. 'Z', 'a' .. 'z'];
{$ENDIF}
end;

class function TCPTokenizer.IsTokenCharacter(C: Char): Boolean;
var
  I: Integer;
begin
  Result := true;
  if (IsIdentifier(C, false)) or (IsIdentifier(C, true)) or (IsDigit(C)) or
    (IsWhitespace(C)) or (C = CPLeftParen) or (C = CPRightParen) or
    (C = CPArgSeparator) or (C = CPSignPositive) or (C = CPSignNegative) then
    exit;
  for I := Low(CPOperatorTokenKeys) to High(CPOperatorTokenKeys) do
  begin
    if Pos(C, CPOperatorTokenKeys[I]) <> 0 then
      exit;
  end;
  Result := false;
end;

class function TCPTokenizer.IsDigit(C: Char): Boolean;
begin
{$IFDEF UNICODE}
  Result := TCharacter.IsDigit(C);
{$ELSE}
  Result := (C >= '0') and (C <= '9');
{$ENDIF}
end;

class function TCPTokenizer.IsIdentifier(C: Char; FirstCharacter: Boolean)
  : Boolean;
begin
  // An identifier may consist of letters, digits and "_", but may not start
  // with a digit:
  Result := (IsLetter(C) or (C = '_')) or (IsDigit(C) and not FirstCharacter);
end;

class function TCPTokenizer.IsWhitespace(C: Char): Boolean;
begin
  Result := (C = #32) or (C = #9) or (C = #13) or (C = #10);
end;

class function TCPTokenizer.GetExpectedTokenAsString(
  Expected: TCPExpectedTokenKind): string;
var
  S: string;
begin
  Result := '';
  S := ', ';
  if etOperator in Expected then
    Result := Result + _(CPTokenKindStrings[tkOperator]) + S;
  if etOperand in Expected then
    Result := Result + _(CPTokenKindStrings[tkVariable]) + S +
      _(CPTokenKindStrings[tkNumber]) + S +
      _(CPTokenKindStrings[tkBuiltinFunction]) + S +
      _(CPTokenKindStrings[tkSign]) + S;
  if etLeftParen in Expected then
    Result := Result + _(CPTokenKindStrings[tkLeftParen]) + S;
  if etRightParen in Expected then
    Result := Result + _(CPTokenKindStrings[tkRightParen]) + S;
  if etArgSeparator in Expected then
    Result := Result + _(CPTokenKindStrings[tkArgSeparator]) + S;
  Delete(Result, Length(Result) - 1, 2);
end;

procedure TCPTokenizer.RaiseError(ErrorCode: TCPErrorCode;
  Expected: TCPExpectedTokenKind; Start, Stop: Integer);
var
  Arg: string;
begin
  if Stop = -1 then
    Stop := Start + 1;
  Arg := '';
  if ErrorCode = ecUnexpectedToken then
    Arg := GetExpectedTokenAsString(Expected);

  raise ECPInvalidExpressionException.Create(
    ErrorCode,
    TCPTextSequence.Create(FSequence.Text, Start, Stop), Arg);
end;

function TCPTokenizer.CheckDigits: Integer;
begin
  Result := -1;
  while (FIndex < FSequence.Stop) and (IsDigit(FSequence[FIndex])) do
  begin
    Inc(FIndex);
    Result := FIndex;
  end;
end;

function TCPTokenizer.CheckString(const Text: string): Integer;
begin
  if Text = Copy(FSequence.Text, FTokenStopIndex, Length(Text)) then
    Result := FTokenStopIndex
  else
    Result := -1;
end;

function TCPTokenizer.ScanArgSeparator: Boolean;
begin
  Result := FSequence[FIndex] = CPArgSeparator;
  if Result then
  begin
    Inc(FIndex);
    AddToken(TCPToken.Create(tkArgSeparator, FParenLevel));
    FExpected := [etWhitespace, etOperand, etLeftParen];
  end
  else
    Exclude(FExpected, etArgSeparator);
end;

function TCPTokenizer.ScanIdentifier: Boolean;
var
  FirstChar: Boolean;
  Token: TCPToken;
begin
  FirstChar := true;
  while (FIndex < FSequence.Stop) and
    (IsIdentifier(FSequence[FIndex], FirstChar)) do
  begin
    Inc(FIndex);
    FirstChar := false;
  end;
  Result := FIndex > FTokenStopIndex;
  if not Result then
    exit;
  Token := TCPIdentifierToken.Create(tkVariable, FParenLevel);
  AddToken(Token);
  // Read ahead to test if token is a function:
  ScanWhitespace;
  if (FIndex < FSequence.Stop) and (FSequence[FIndex] = CPLeftParen) then
  begin
    Token.Kind := tkBuiltinFunction;
    FExpected := [etWhitespace, etLeftParen];
  end
  else
    FExpected := [etWhitespace, etOperator, etArgSeparator, etRightParen];
end;

function TCPTokenizer.ScanNumber: Boolean;
var
  IntPartStop: Integer;
  FractPartStop: Integer;
  ExpPartStop: Integer;
  Value: Double;
  C: Char;
  Token: TCPNumberToken;
begin
  Result := false;
  // Scan significand:
  IntPartStop := CheckDigits;
  if (FIndex < FSequence.Stop) and
    (FSequence[FIndex] = CPFormatSettings.DecimalSeparator) then
  begin
    Inc(FIndex);
    FractPartStop := CheckDigits;
    // At least one digit expected after decimal separator:
    if (IntPartStop = -1) and (FractPartStop = -1) then
      RaiseError(ecInvalidSignificand, [], FTokenStopIndex, FIndex);
  end
  else
    FractPartStop := -1; // No fractional part
  if (IntPartStop = -1) and (FractPartStop = -1) then
    exit;
  // Scan exponent:
  if (FIndex < FSequence.Stop) and ((FSequence[FIndex] = 'e') or
      (FSequence[FIndex] = 'E')) then
  begin
    Inc(FIndex);
    // Scan optional exponent sign:
    if (FIndex < FSequence.Stop) then
    begin
      C := FSequence[FIndex];
      if (C = '-') or (C = '+') then
        Inc(FIndex);
    end;
    // Scan exponent digits:
    ExpPartStop := CheckDigits;
    if (ExpPartStop = -1) then // At least one exponent digit expected
      RaiseError(ecInvalidNumber, [], FTokenStopIndex, FIndex);
  end;
  Value := StrToFloat(Copy(FSequence.Text, FTokenStopIndex,
      FIndex - FTokenStopIndex), CPFormatSettings);
  Token := TCPNumberToken(AddToken(
    TCPNumberToken.Create(tkNumber, FParenLevel)));
  Token.Value := Value;
  FExpected := [etWhitespace, etOperator, etArgSeparator, etRightParen];
  Result := true;
end;

function TCPTokenizer.ScanOperator: Boolean;
var
  I, StartIndex: Integer;
  Token: TCPOperatorToken;
begin
  for I := Low(CPOperatorTokenKeys) to High(CPOperatorTokenKeys) do
  begin
    StartIndex := CheckString(CPOperatorTokenKeys[I]);
    if StartIndex <> -1 then
    begin
      FIndex := StartIndex + Length(CPOperatorTokenKeys[I]);
      Token := TCPOperatorToken(AddToken(
        TCPOperatorToken.Create(tkOperator, FParenLevel)));
      Token.Operator := CPOperatorTokenValues[I];
      Result := true;
      FExpected := [etWhitespace, etOperand, etLeftParen];
      exit;
    end;
  end;
  Exclude(FExpected, etOperator);
  Result := false;
end;

function TCPTokenizer.ScanSign: Boolean;
var
  C: Char;
  Token: TCPOperatorToken;
begin
  C := FSequence[FIndex];
  Result := (C = CPSignPositive) or (C = CPSignNegative);
  if Result then
  begin
    Inc(FIndex);
    if C = CPSignNegative then
    begin
      Token := TCPOperatorToken(AddToken(
        TCPOperatorToken.Create(tkOperator, FParenLevel)));
      Token.Operator := @CPOperatorSignNegative
    end
    else
      FTokenStopIndex := FIndex; // Skip positive sign
    FExpected := [etWhitespace, etOperand, etLeftParen];
  end;

end;

function TCPTokenizer.ScanWhitespace: Boolean;
begin
  // Scan for a consecutive sequence of whitespace characters:
  while (IsWhitespace(FSequence[FIndex])) and (FIndex < FSequence.Stop) do
    Inc(FIndex);
  Result := FIndex > FTokenStopIndex;
  if Result then
    AddToken(TCPToken.Create(tkWhitespace, FParenLevel));
  Exclude(FExpected, etWhitespace);
end;

function TCPTokenizer.ScanParen: Boolean;
var
  Kind: TCPTokenKind;
begin
  if (FSequence[FIndex] = CPLeftParen) and (etLeftParen in FExpected) then
  begin
    FExpected := [etWhitespace, etOperand, etLeftParen];
    Kind := tkLeftParen;
    Inc(FParenLevel);
  end
  else if (FSequence[FIndex] = CPRightParen) and
    (etRightParen in FExpected) then
  begin
    FExpected := [etWhitespace, etOperator, etArgSeparator, etRightParen,
      etEnd];
    Kind := tkRightParen;
    Dec(FParenLevel);
    // Found closing paren without a matching opening paren:
    if FParenLevel < 0 then
      RaiseError(ecInvalidRightParen, [], FTokenStopIndex, FIndex);
  end
  else
  begin
    // No parentheses found:
    Exclude(FExpected, etLeftParen);
    Exclude(FExpected, etRightParen);
    Result := false;
    exit;
  end;
  Inc(FIndex);
  AddToken(TCPToken.Create(Kind, FParenLevel));
  Result := true;
end;

function TCPTokenizer.ScanOperand: Boolean;
var
  FoundNumber: Boolean;
begin
  // Read all possible signs or whitespace before operand:
  while ScanSign or ScanWhitespace do;
  FoundNumber := ScanNumber;
  Result := FoundNumber or ScanIdentifier;

  Exclude(FExpected, etOperand);
  if FoundNumber then
    Exclude(FExpected, etLeftParen); // No left paren after number
  if Result then
    Include(FExpected, etEnd);
end;

procedure TCPTokenizer.Tokenize;
var
  B: Boolean;
begin
  FIndex := FSequence.Start;
  FTokenStopIndex := FIndex;
  FExpected := [etWhitespace, etOperand, etLeftParen];
  FInitialExpected := FExpected;
  FParenLevel := 0;
  B := true;
  while FTokenStopIndex < FSequence.Stop do
  begin
    if etWhitespace in FExpected then
      B := ScanWhitespace
    else if etOperand in FExpected then
      B := ScanOperand
    else if etOperator in FExpected then
      B := ScanOperator
    else if (etLeftParen in FExpected) or (etRightParen in FExpected) then
      B := ScanParen
    else if (etArgSeparator in FExpected) then
      B := ScanArgSeparator
    else
    begin
      // Raise error, if current character could not be read:
      if not IsTokenCharacter(FSequence[FIndex]) then
        RaiseError(ecInvalidCharacter, [], FIndex, FIndex + 1)
      else
      RaiseError(ecUnexpectedToken, FInitialExpected, FIndex);
    end;
    // If token was read, store its expected next tokens:
    if B then
      FInitialExpected := FExpected;
  end;
  if FParenLevel > 0 then
  begin
    Exclude(FExpected, etEnd);
    Include(FExpected, etRightParen);
  end;

  if not(etEnd in FExpected) then
    RaiseError(ecUnexpectedToken, FInitialExpected, FIndex);
    Tokens.SelectFirst;
end;

{ TCPTokenList }

function TCPTokenList.GetCurrent: TCPToken;
begin
  Result := TCPToken(Items[FTokenIndex]);
end;

function TCPTokenList.GetPrevious: TCPToken;
begin
  if FTokenIndex > 0 then
    Result := TCPToken(Items[FTokenIndex - 1])
  else
    Result := nil;
end;

function TCPTokenList.GetTokens(Index: Integer): TCPToken;
begin
  Result := TCPToken(Items[Index]);
end;

procedure TCPTokenList.SelectFirst;
begin
  FTokenIndex := 0;
end;

function TCPTokenList.SelectNext: Boolean;
begin
  Result := FTokenIndex < (Count - 1);
  if Result then
    Inc(FTokenIndex);
end;

procedure TCPTokenList.SetTokens(Index: Integer; const Value: TCPToken);
begin
  Items[Index] := Value;
end;

end.
